home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_guile.idb / usr / freeware / share / guile / 1.3 / ice-9 / session.scm.z / session.scm
Encoding:
Text File  |  1999-04-16  |  3.5 KB  |  126 lines
  1. ;;;;     Copyright (C) 1997 Free Software Foundation, Inc.
  2. ;;;; 
  3. ;;;; This program is free software; you can redistribute it and/or modify
  4. ;;;; it under the terms of the GNU General Public License as published by
  5. ;;;; the Free Software Foundation; either version 2, or (at your option)
  6. ;;;; any later version.
  7. ;;;; 
  8. ;;;; This program is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. ;;;; GNU General Public License for more details.
  12. ;;;; 
  13. ;;;; You should have received a copy of the GNU General Public License
  14. ;;;; along with this software; see the file COPYING.  If not, write to
  15. ;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ;;;; 
  17.  
  18.  
  19. (define-module (ice-9 session))
  20.  
  21.  
  22.  
  23. ;;; {Apropos}
  24. ;;;
  25. ;;; Author: Roland Orre <orre@nada.kth.se>
  26. ;;;
  27.  
  28. (define (id x) x)
  29.  
  30. (define-public (apropos rgx . options)
  31.   "Search for bindings: apropos regexp {options= 'full 'shadow 'value}"
  32.   (if (zero? (string-length rgx))
  33.       "Empty string not allowed"
  34.       (let* ((match (make-regexp rgx))
  35.          (modules (cons (current-module)
  36.                 (module-uses (current-module))))
  37.          (separator #\tab)
  38.          (shadow (member 'shadow options))
  39.          (value (member 'value options)))
  40.     (cond ((member 'full options)
  41.            (set! shadow #t)
  42.            (set! value #t)))
  43.     (for-each
  44.      (lambda (module)
  45.        (let* ((builtin (or (eq? module the-scm-module)
  46.                    (eq? module the-root-module)))
  47.           (name (module-name module))
  48.           (obarrays (if builtin
  49.                 (list (builtin-weak-bindings)
  50.                       (builtin-bindings))
  51.                 (list (module-obarray module))))
  52.           (get-refs (if builtin
  53.                 (list id id)
  54.                 (list variable-ref)))
  55.           )
  56.          (for-each
  57.           (lambda (obarray get-ref)
  58.         (array-for-each
  59.          (lambda (oblist)
  60.            (for-each
  61.             (lambda (x)
  62.               (cond ((regexp-exec match (car x))
  63.                  (display name)
  64.                  (display ": ")
  65.                  (display (car x))
  66.                  (cond ((procedure? (get-ref (cdr x)))
  67.                     (display separator)
  68.                     (display (get-ref (cdr x))))
  69.                    (value
  70.                     (display separator)
  71.                     (display (get-ref (cdr x)))))
  72.                  (if (and shadow
  73.                       (not (eq? (module-ref module
  74.                                 (car x))
  75.                         (module-ref (current-module)
  76.                                 (car x)))))
  77.                  (display " shadowed"))
  78.                  (newline)
  79.                  )))
  80.             oblist))
  81.          obarray))
  82.           obarrays get-refs)))
  83.      modules))))
  84.  
  85. (define-public (apropos-internal rgx)
  86.   "Return a list of accessible variable names."
  87.   (let ((match (make-regexp rgx))
  88.     (modules (cons (current-module)
  89.                (module-uses (current-module))))
  90.     (recorded (make-vector 61 '()))
  91.     (vars (cons '() '())))
  92.     (let ((last vars))
  93.       (for-each
  94.        (lambda (module)
  95.      (for-each
  96.       (lambda (obarray)
  97.         (array-for-each
  98.          (lambda (oblist)
  99.            (for-each
  100.         (lambda (x)
  101.           (if (and (regexp-exec match (car x))
  102.                (not (hashq-get-handle recorded (car x))))
  103.               (begin
  104.             (set-cdr! last (cons (car x) '()))
  105.             (set! last (cdr last))
  106.             (hashq-set! recorded (car x) #t))))
  107.         oblist))
  108.          obarray))
  109.       (if (or (eq? module the-scm-module)
  110.           (eq? module the-root-module))
  111.           (list (builtin-weak-bindings)
  112.             (builtin-bindings))
  113.           (list (module-obarray module)))))
  114.        modules))
  115.     (cdr vars)))
  116.  
  117. (define-public (name obj)
  118.   (cond ((procedure? obj) (procedure-name obj))
  119.     ((macro? obj) (macro-name obj))
  120.     (else #f)))
  121.  
  122. (define-public (source obj)
  123.   (cond ((procedure? obj) (procedure-source obj))
  124.     ((macro? obj) (procedure-source (macro-transformer obj)))
  125.     (else #f)))
  126.